home *** CD-ROM | disk | FTP | other *** search
/ Otherware / Otherware_1_SB_Development.iso / mac / developm / language / xlispst.cpt / XLisp-Stat ƒ / Disk 1 / objects.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1990-08-15  |  6.0 KB  |  176 lines
  1. ;;;;
  2. ;;;; objects.lsp XLISP-STAT additional objects and object functions
  3. ;;;; XLISP-STAT 2.1 Copyright (c) 1990, by Luke Tierney
  4. ;;;; Additions to Xlisp 2.1, Copyright (c) 1989 by David Michael Betz
  5. ;;;; You may give out copies of this software; for conditions see the file
  6. ;;;; COPYING included with this distribution.
  7. ;;;;
  8.  
  9. (provide "objects")
  10.  
  11. (defsetf slot-value slot-value)
  12.  
  13. (defmeth *object* :new (&rest args)
  14. "Method args: (&rest args)
  15. Creates new object using self as prototype."
  16.   (let* ((object (make-object self)))
  17.     (if (slot-value 'instance-slots)
  18.         (dolist (s (slot-value 'instance-slots))
  19.                 (send object :add-slot s (slot-value s))))
  20.     (apply #'send object :isnew args)
  21.     object))
  22.  
  23. (defmeth *object* :retype (proto &rest args)
  24. "Method args: (proto &rest args)
  25. Changes object to inherit directly from prototype PROTO. PROTO
  26. must be a prototype and SELF must not be one."
  27.   (if (send self :has-slot 'instance-slots :own t) 
  28.       (error "can't retype a prototype"))
  29.   (if (not (send proto :has-slot 'instance-slots :own t))
  30.       (error "not a prototype - ~a" proto))
  31.   (send self :reparent proto)
  32.   (dolist (s (send proto :slot-value 'instance-slots))
  33.     (send self :add-slot s (slot-value s)))
  34.   (apply #'send self :isnew args)
  35.   self)
  36.  
  37. (defmeth *object* :print (&optional (stream *standard-output*))
  38. "Method args: (&optional (stream *standard-output*))
  39. Default object printing method."
  40.   (cond
  41.     ((send self :has-slot 'proto-name) 
  42.      (format stream
  43.              "#<Object: ~D, prototype = ~A>"
  44.              (address-of self)
  45.              (slot-value 'proto-name)))
  46.     (t (format stream "#<Object: ~D>" (address-of self)))))
  47.  
  48. (defmeth *object* :slot-value (sym &optional (val nil set))
  49. "Method args: (sym &optional val)
  50. Sets and retrieves value of slot named SYM. Sugnals an error if slot
  51. does not exist."
  52.   (if set (setf (slot-value sym) val))
  53.   (slot-value sym))
  54.  
  55. (defmeth *object* :slot-names () 
  56. "Method args: ()
  57. Returns list of slots available to the object."
  58.   (apply #'append 
  59.          (mapcar #'(lambda (x) (send x :own-slots))
  60.                  (send self :precedence-list))))
  61.  
  62. (defmeth *object* :method-selectors ()
  63. "Method args: ()
  64. Returns list of method selectors available to object."
  65.   (apply #'append
  66.          (mapcar #'(lambda (x) (send x :own-methods))
  67.                  (send self :precedence-list))))
  68.  
  69. ;;;;
  70. ;;;; More Hardware Object Methods
  71. ;;;;
  72.  
  73. (defmeth hardware-object-proto :remove () (send self :dispose))
  74. (defmeth hardware-object-proto :allocated-p () (slot-value 'hardware-address))
  75.  
  76. (defmeth hardware-object-proto :add-subordinate (d)
  77.   (setf (slot-value 'subordinates) (adjoin d (slot-value 'subordinates))))
  78.  
  79. (defmeth hardware-object-proto :delete-subordinate (d)
  80.   (setf (slot-value 'subordinates) (remove d (slot-value 'subordinates))))
  81.   
  82. (defmeth hardware-object-proto :clobber ()
  83.   (if (slot-value 'subordinates)
  84.       (dolist (i (slot-value 'subordinates)) (send i :remove))))
  85.  
  86. #+macintosh (progn
  87.              ;;; DISPLAY-WINDOW-PROTO
  88.              (defproto display-window-proto '() '() edit-window-proto)
  89.  
  90.              (defmeth display-window-proto :isnew (&rest args)
  91.                (apply #'call-next-method args)
  92.                (setf (slot-value 'input-enabled) nil)))
  93.  
  94. (defun active-windows ()
  95. "Args: ()
  96. Returns list of active windows."
  97.     (remove-if-not #'(lambda (x) (kind-of-p x window-proto))
  98.                    (mapcar #'third *hardware-objects*)))
  99.  
  100. ;;;;
  101. ;;;; More Dialogs and Menu Items
  102. ;;;;
  103.  
  104. (send dialog-proto :slot-value 'type 'modeless)
  105. (send dialog-proto :slot-value 'go-away t)
  106.  
  107. (defmeth dialog-proto :items () (slot-value 'items))
  108.  
  109. (defmeth dialog-item-proto :dialog () (slot-value 'dialog))
  110.  
  111. (defproto edit-text-item-proto () () text-item-proto)
  112. (send edit-text-item-proto :slot-value 'editable t)
  113.  
  114. ;;; MODAL-DIALOG-PROTO
  115. (defproto modal-dialog-proto '(modal-throw-target) () dialog-proto)
  116. (send modal-dialog-proto :slot-value 'type 'modal)
  117. (send modal-dialog-proto :slot-value 'go-away nil)
  118.  
  119. (defmeth modal-dialog-proto :modal-dialog (&optional (remove t))
  120. "Metod args: (&optional (remove t))
  121. Runs the modal dialog loop until the :modal-dialog-return message
  122. is sent. Returns the argument to :modal-dialog-return. If REMOVE
  123. is not NIL, dialog is sent the :remove message before returning."
  124.   (let ((target self))
  125.     (unless (slot-value 'modal-throw-target)
  126.             (setf (slot-value 'modal-throw-target) target)
  127.             (send self :show-window)
  128.             (unwind-protect (catch target 
  129.                                    (loop (send (call-next-method) :do-action)))
  130.                             (setf (slot-value 'modal-throw-target) nil)
  131.                             (if remove (send self :remove))))))
  132.  
  133. (defmeth modal-dialog-proto :modal-dialog-return (value)
  134. "Method Args: (value)
  135. Ends modal dialog loop and has :modal-dialog return VALUE."
  136.   (let ((target (slot-value 'modal-throw-target)))
  137.     (if target (throw target value))))
  138.  
  139. ;;; MODAL-BUTTON-PROTO
  140. (defproto modal-button-proto '() () button-item-proto)
  141.   
  142. (defmeth modal-button-proto :do-action ()
  143.   (let ((action (slot-value 'action))
  144.         (dialog (slot-value 'dialog)))
  145.     (if dialog 
  146.         (send dialog :modal-dialog-return (if action (funcall action))))))
  147.  
  148. ;; DASH-ITEM-PROTO. Disabled line item for separation 
  149. (defproto dash-item-proto () () menu-item-proto "Disabled separator line")
  150.  
  151. (defmeth dash-item-proto :isnew () (call-next-method "-" :enabled nil))
  152.  
  153. (defmeth menu-item-proto :menu () 
  154. "Method args: ()
  155. Returns menu if item is installed, NIL otherwise."
  156.   (slot-value 'menu))
  157.  
  158. (defmeth menu-proto :print (&optional (stream t))
  159.   (format stream "#<Object: ~d, prototype = ~a, title = ~s>"
  160.           (address-of self)
  161.           (slot-value 'proto-name)
  162.           (slot-value 'title)))
  163.  
  164. (defmeth menu-item-proto :print (&optional stream)
  165.   (format stream "#<Object: ~d, prototype = ~a, title = ~s>"
  166.           (address-of self)
  167.           (slot-value 'proto-name)
  168.           (slot-value 'title)))
  169.  
  170. (defmeth graph-window-proto :erase-window ()
  171. "Method args: ()
  172. Erases the entire window canvas."
  173.   (let ((w (send self :canvas-width))
  174.         (h (send self :canvas-height)))
  175.     (send self :erase-rect 0 0 w h)))
  176.